home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / STRNTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  13KB  |  482 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.02                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  StrnTTT5          }
  14.                      {--------------------------------}
  15.  
  16. { Update History:    5.01a   Added DEBUG compiler directive
  17. }
  18.  
  19. {$S-,R-,V-}
  20. {$IFNDEF DEBUG}
  21. {$D-}
  22. {$ENDIF}       
  23.  
  24. unit StrnTTT5;
  25.  
  26. interface
  27.  
  28. CONST
  29.     Floating = 255;
  30.  
  31. Function Squeeze(L:char;Str:string;Width:byte): string;
  32. Function First_Capital_Pos(Str:string): byte;
  33. Function First_Capital(Str:string): char;
  34. Function PadLeft(Str:string;Size:byte;Pad:char):string;
  35. Function PadCenter(Str:string;Size:byte;Pad:char):string;
  36. Function PadRight(Str:string;Size:byte;Pad:char):string;
  37. Function Last(N:byte;Str:string):string;
  38. Function First(N:byte;Str:string):string;
  39. Function Upper(Str:string):string;
  40. Function Lower(Str:string):string;
  41. Function Proper(Str:string):string;
  42. Function OverType(N:byte;StrS,StrT:string):string;
  43. Function Strip(L,C:char;Str:string):string;
  44. Function LastPos(C:Char;Str:string):byte;
  45. Function PosWord(Wordno:byte;Str:string):byte;
  46. Function WordCnt(Str:string):byte;
  47. Function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  48. Function Str_to_Int(Str:string):integer;
  49. Function Str_to_Long(Str:string):Longint;
  50. Function Str_to_Real(Str:string):real;
  51. Function Real_to_str(Number:real;Decimals:byte):string;
  52. Function Int_to_Str(Number:longint):string;
  53. Function Real_to_SciStr(Number:real; D:byte):string;
  54.  
  55. implementation
  56.  
  57.  Function Squeeze(L:Char; Str:string;Width:byte): string;
  58.  {}
  59.  const more:string[1] = #26;
  60.  var temp : string;
  61.  begin
  62.      If Width = 0 then
  63.      begin
  64.          Squeeze := '';
  65.          exit;
  66.      end;
  67.      Fillchar(Temp[1],Width,' ');
  68.      Temp[0] := chr(Width);
  69.      If Length(Str) < Width then
  70.         Move(Str[1],Temp[1],length(Str))
  71.      else
  72.      begin
  73.          If upcase(L) = 'L' then
  74.          begin
  75.              Move(Str[1],Temp[1],pred(width));
  76.              Move(More[1],Temp[Width],1);
  77.          end
  78.          else
  79.          begin
  80.              Move(More[1],Temp[1],1);
  81.              Move(Str[length(Str)-width+2],Temp[2],pred(width));
  82.          end;
  83.      end;
  84.      Squeeze := Temp;
  85.  end; {of func Squeeze}
  86.  
  87.  Function First_Capital_Pos(Str : string): byte;
  88.  {}
  89.  var StrPos : byte;
  90.  begin
  91.      StrPos := 1;
  92.      While (StrPos <= length(Str))  and ((Str[StrPos] in ['A'..'Z']) = false) do
  93.             StrPos := Succ(StrPos);
  94.      If StrPos > length(Str) then
  95.         First_Capital_Pos  := 0
  96.      else
  97.         First_Capital_Pos := StrPos;
  98.  end; {of func First_Capital_Pos}
  99.  
  100.  Function First_capital(Str : string): char;
  101.  {}
  102.  var B : byte;
  103.  begin
  104.      B := First_Capital_Pos(Str);
  105.      If B > 0 then
  106.         First_Capital := Str[B]
  107.      else
  108.         First_Capital := #0;
  109.  end; {of func First_capital}
  110.  
  111. Function PadLeft(Str:string;Size:byte;Pad:char):string;
  112. var temp : string;
  113. begin
  114.     Fillchar(Temp[1],Size,Pad);
  115.     Temp[0] := chr(Size);
  116.     If Length(Str) <= Size then
  117.        Move(Str[1],Temp[1],length(Str))
  118.     else
  119.        Move(Str[1],Temp[1],size);
  120.     PadLeft := Temp;
  121. end;
  122.  
  123. Function PadCenter(Str:string;Size:byte;Pad:char):string;
  124. var temp : string;
  125. L : byte;
  126. begin
  127.     Fillchar(Temp[1],Size,Pad);
  128.     Temp[0] := chr(Size);
  129.     L := length(Str);
  130.     If L <= Size then
  131.        Move(Str[1],Temp[((Size - L) div 2) + 1],L)
  132.     else
  133.        Move(Str[((L - Size) div 2) + 1],Temp[1],Size);
  134.     PadCenter := temp;
  135. end; {center}
  136.  
  137. Function PadRight(Str:string;Size:byte;Pad:char):string;
  138. var
  139.   temp : string;
  140.   L : integer;
  141. begin
  142.     Fillchar(Temp[1],Size,Pad);
  143.     Temp[0] := chr(Size);
  144.     L := length(Str);
  145.     If L <= Size then
  146.        Move(Str[1],Temp[succ(Size - L)],L)
  147.     else
  148.        Move(Str[1],Temp[1],size);
  149.     PadRight := Temp;
  150. end;
  151.  
  152. Function Last(N:byte;Str:string):string;
  153. var Temp : string;
  154. begin
  155.     If N > length(Str) then
  156.        Temp := Str
  157.     else
  158.        Temp := copy(Str,succ(length(Str) - N),N);
  159.     Last := Temp;
  160. end;  {Func Last}
  161.  
  162. Function First(N:byte;Str:string):string;
  163. var Temp : string;
  164. begin
  165.     If N > length(Str) then
  166.        Temp := Str
  167.     else
  168.        Temp := copy(Str,1,N);
  169.     First := Temp;
  170. end;  {Func First}
  171.  
  172. Function Upper(Str:string):string;
  173. var
  174.   I : integer;
  175. begin
  176.     For I := 1 to length(Str) do
  177.         Str[I] := Upcase(Str[I]);
  178.     Upper := Str;
  179. end;  {Func Upper}
  180.  
  181. Function Lower(Str:string):string;
  182. var
  183.   I : integer;
  184. begin
  185.     For I := 1 to length(Str) do
  186.         If ord(Str[I]) in [65..90] then
  187.            Str[I] := chr(ord(Str[I]) + 32);
  188.     Lower := Str;
  189. end;  {Func Lower}
  190.  
  191. Function Proper(Str:string):string;
  192. var
  193.   I : integer;
  194.   SpaceBefore: boolean;
  195. begin
  196.     SpaceBefore := true;
  197.     Str := lower(Str);
  198.     For I := 1 to length(Str) do
  199.         If SpaceBefore and (ord(Str[I]) in [97..122]) then
  200.         begin
  201.             SpaceBefore := False;
  202.             Str[I] := Upcase(Str[I]);
  203.         end
  204.         else
  205.             If (SpaceBefore = False) and (Str[I] = ' ') then
  206.                 SpaceBefore := true;
  207.     Proper := Str;
  208. end;
  209.  
  210. Function OverType(N:byte;StrS,StrT:string):string;
  211. {Overlays StrS onto StrT at Pos N}
  212. var
  213.   L : byte;
  214.   StrN : string;
  215. begin
  216.     L := N + pred(length(StrS));
  217.     If L < length(StrT) then
  218.        L := length(StrT);
  219.     If L > 255 then
  220.        Overtype := copy(StrT,1,pred(N)) + copy(StrS,1,255-N)
  221.         else
  222.     begin
  223.        Fillchar(StrN[1],L,' ');
  224.        StrN[0] := chr(L);
  225.        Move(StrT[1],StrN[1],length(StrT));
  226.        Move(StrS[1],StrN[N],length(StrS));
  227.        OverType := StrN;
  228.     end;
  229. end;  {Func OverType}
  230.  
  231. Function Strip(L,C:char;Str:string):string;
  232. {L is left,center,right,all,ends}
  233. var I :  byte;
  234. begin
  235.     Case Upcase(L) of
  236.     'L' : begin       {Left}
  237.               While (Str[1] = C) and (length(Str) > 0) do
  238.                     Delete(Str,1,1);
  239.           end;
  240.     'R' : begin       {Right}
  241.               While (Str[length(Str)] = C) and (length(Str) > 0) do
  242.                     Delete(Str,length(Str),1);
  243.           end;
  244.     'B' : begin       {Both left and right}
  245.               While (Str[1] = C) and (length(Str) > 0) do
  246.                     Delete(Str,1,1);
  247.               While (Str[length(Str)] = C) and (length(Str) > 0)  do
  248.                     Delete(Str,length(Str),1);
  249.           end;
  250.     'A' : begin       {All}
  251.               I := 1;
  252.               Repeat
  253.                    If (Str[I] = C) and (length(Str) > 0) then
  254.                       Delete(Str,I,1)
  255.                    else
  256.                       I := succ(I);
  257.               Until (I > length(Str)) or (Str = '');
  258.           end;
  259.     end;
  260.     Strip := Str;
  261. end;  {Func Strip}
  262.  
  263. Function LastPos(C:Char;Str:string):byte;
  264. Var I : byte;
  265. begin
  266.     I := succ(Length(Str));
  267.     Repeat
  268.          I := Pred(I);
  269.     Until (I = 0) or (Str[I] = C);
  270.     LastPos := I;
  271. end;  {Func LastPos}
  272.  
  273. Function LocWord(StartAT,Wordno:byte;Str:string):byte;
  274. {local proc used by PosWord and Extract word}
  275. var
  276.   W,L: integer;
  277.   Spacebefore: boolean;
  278. begin
  279.     If (Str = '') or (wordno < 1) or (StartAT > length(Str)) then
  280.     begin
  281.         LocWord := 0;
  282.         exit;
  283.     end;
  284.     SpaceBefore := true;
  285.     W := 0;
  286.     L := length(Str);
  287.     StartAT := pred(StartAT);
  288.     While (W < Wordno) and (StartAT <= length(Str)) do
  289.     begin
  290.         StartAT := succ(StartAT);
  291.         If SpaceBefore and (Str[StartAT] <> ' ') then
  292.         begin
  293.             W := succ(W);
  294.             SpaceBefore := false;
  295.         end
  296.         else
  297.             If (SpaceBefore = false) and (Str[StartAT] = ' ') then
  298.                 SpaceBefore := true;
  299.     end;
  300.     If W = Wordno then
  301.        LocWord := StartAT
  302.     else
  303.        LocWord := 0;
  304. end;
  305.  
  306. Function PosWord(Wordno:byte;Str:string):byte;
  307. begin
  308.     PosWord := LocWord(1,wordno,Str);
  309. end;  {Func Word}
  310.  
  311. Function WordCnt(Str:string):byte;
  312. var
  313.   W,I: integer;
  314.   SpaceBefore: boolean;
  315. begin
  316.     If Str = '' then
  317.     begin
  318.         WordCnt := 0;
  319.         exit;
  320.     end;
  321.     SpaceBefore := true;
  322.     W := 0;
  323.     For  I :=  1 to length(Str) do
  324.     begin
  325.         If SpaceBefore and (Str[I] <> ' ') then
  326.         begin
  327.             W := succ(W);
  328.             SpaceBefore := false;
  329.         end
  330.         else
  331.             If (SpaceBefore = false) and (Str[I] = ' ') then
  332.                 SpaceBefore := true;
  333.     end;
  334.     WordCnt := W;
  335. end;
  336.  
  337. Function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  338. var Start, finish : integer;
  339. begin
  340.     If Str = '' then
  341.     begin
  342.         ExtractWords := '';
  343.         exit;
  344.     end;
  345.     Start := LocWord(1,StartWord,Str);
  346.     If Start <> 0 then
  347.        finish := LocWord(Start,succ(NoWords),Str)
  348.     else
  349.     begin
  350.         ExtractWords := '';
  351.         exit;
  352.     end;
  353.     If finish <> 0 then
  354.        Repeat
  355.            finish := pred(finish);
  356.        Until Str[finish] <> ' '
  357.     else
  358.        finish := length(Str);
  359.     ExtractWords := copy(Str,Start,succ(finish-Start));
  360. end;  {Func ExtractWords}
  361.  
  362. Function Int_to_Str(Number:longint):string;
  363. var Temp : string;
  364. begin
  365.     Str(Number,temp);
  366.     Int_to_Str := temp;
  367. end;
  368.  
  369. Function Str_to_Real(Str:string):real;
  370. var
  371.   code : integer;
  372.   Temp : real;
  373. begin
  374.     If length(Str) = 0 then
  375.        Str_to_Real := 0
  376.     else
  377.     begin
  378.         If Copy(Str,1,1)='.' Then
  379.            Str:='0'+Str;
  380.         If (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  381.            Insert('0',Str,2);
  382.         If Str[length(Str)] = '.' then
  383.            Delete(Str,length(Str),1);
  384.        val(Str,temp,code);
  385.        if code = 0 then
  386.           Str_to_Real := temp
  387.        else
  388.           Str_to_Real := 0;
  389.     end;
  390. end;
  391.  
  392. function Real_to_str(Number:real;Decimals:byte):string;
  393. var Temp : string;
  394. begin
  395.     Str(Number:20:Decimals,Temp);
  396.     repeat
  397.          If copy(Temp,1,1) = ' ' then delete(Temp,1,1);
  398.     until copy(temp,1,1) <> ' ';
  399.     If Decimals = Floating then
  400.     begin
  401.        Temp := Strip('R','0',Temp);
  402.        If Temp[Length(temp)] = '.' then
  403.           Delete(temp,Length(temp),1);
  404.     end;
  405.     Real_to_Str := Temp;
  406. end;
  407.  
  408. Function  Str_to_Int(Str:string):integer;
  409. var temp,code : integer;
  410. begin
  411.     If length(Str) = 0 then
  412.        Str_to_Int := 0
  413.     else
  414.     begin
  415.        val(Str,temp,code);
  416.        if code = 0 then
  417.           Str_to_Int := temp
  418.        else
  419.           Str_to_Int := 0;
  420.     end;
  421. end;
  422.  
  423. Function Str_to_Long(Str:string):Longint;
  424. var
  425.   code : integer;
  426.   Temp : longint;
  427. begin
  428.     If length(Str) = 0 then
  429.        Str_to_Long := 0
  430.     else
  431.     begin
  432.        val(Str,temp,code);
  433.        if code = 0 then
  434.           Str_to_Long := temp
  435.        else
  436.           Str_to_Long := 0;
  437.     end;
  438. end;
  439.  
  440. Function Real_to_SciStr(Number:real; D:byte):string;
  441. {Credits: Michael Harris, Houston. Thanks!}
  442. Const
  443.     DamnNearUnity = 9.99999999E-01;
  444. Var
  445.     Temp : real;
  446.     Power: integer;
  447.     Value: string;
  448.     Sign : char;
  449. begin
  450.     If Number = 1.0 then
  451.        Real_to_SciStr := '1.000'
  452.     else
  453.     begin
  454.         Temp := Number;
  455.         Power := 0;
  456.         If Number > 1.0 then
  457.         begin
  458.            While Temp >= 10.0 do
  459.            begin
  460.                Inc(Power);
  461.                Temp := Temp/10.0;
  462.            end;
  463.            Sign := '+';
  464.         end
  465.         else
  466.         begin
  467.             While Temp < DamnNearUnity do
  468.             begin
  469.                 Inc(Power);
  470.                 Temp := Temp * 10.0;
  471.             end;
  472.             Sign := '-';
  473.         end;
  474.         Value := Real_To_Str(Temp,D);
  475.         Real_to_SciStr := Value+' E'+Sign+Padright(Int_to_Str(Power),2,'0');
  476.     end;
  477. end; {func Real_to_SciStr}
  478.  
  479. begin    {unit initialization}
  480. end.
  481.  
  482.